;;; -*- Syntax: Common-lisp; Package: PZ -*-

;(defun bf (u good bad)
;  (cond
;    ((null u) (error "lose"))
;    ((good (car u)) (car u))
;    ((bad (car u)) (bf (cdr u) good bad))
;    (t (bf (merge (cdr u) (succ (car u))) good bad))))

;(defun improve (p)
;  (bf (succ p) #'(lambda (p1) (better p1 p))
;      #'(lambda (p1) (worse p1 p))))

;;; (adjoin x u) adjoins the element  x  to the list  u,
;;; and (merge u v)  merges the lists  u  and  v.
 
(def-worse-heuristic dont-break-chain (newboard oldboard)
  (unless (zerop (board-completed-chain oldboard))	; No chain to break.
    (let* ((lefttile  (leftsquare (board-completed-chain oldboard) oldboard))
	   (righttile (board-completed-chain oldboard)))
      (dont-break-chain-1 lefttile righttile newboard))))

;(def-worse-heuristic dont-break-chain (newboard oldboard)
;  (unless (zerop (board-completed-chain oldboard))	; No chain to break.
;    (let* ((lefttile  (leftsquare (board-completed-chain oldboard) oldboard))
;	   (righttile (board-completed-chain oldboard)))
;      (loop for tilenumber from lefttile below righttile
;	    when (not (contiguous tilenumber
;				  (1+ tilenumber) newboard))
;	      return t))))

(defun dont-break-chain-1 (m n board)
  (if (= m n)
      nil
      (if (contiguous-1 m (1+ m) board)
	  (dont-break-chain-1 (1+ m) n board)
	  (if (contiguous m (1+ m) board)
	      (dont-break-chain-2 (1+ m) n board)
	      t))))

(defun dont-break-chain-2 (m n board)
  (if (= m n)
      nil
      (if (contiguous-1 m (1+ m) board)
	  (dont-break-chain-2 (1+ m) n board)
	  t)))

(defun contiguous (tile1 tile2 board)
  (let ((p1 (current-position tile1 board))
	(p2 (current-position tile2 board)))
    (or (and (= (row p1 board)(row p2 board))
	     (= (abs (- (column p1 board)(column p2 board))) 1))
	(and (= (column p1 board)(column p2 board))
	     (= (abs (- (row p1 board)(row p2 board))) 1))
	(and (not (or (eq tile1 :blank)(eq tile2 :blank)))
	     (contiguous tile1 :blank board)
	     (contiguous tile2 :blank board)))))

;;; contiguous without allowing intervening blanks
(defun contiguous-1 (tile1 tile2 board)
  (let ((p1 (current-position tile1 board))
	(p2 (current-position tile2 board)))
    (or (and (= (row p1 board)(row p2 board))
	     (= (abs (- (column p1 board)(column p2 board))) 1))
	(and (= (column p1 board)(column p2 board))
	     (= (abs (- (row p1 board)(row p2 board))) 1)))))
 
(defun whither-next (tile location board)
  
)

(def-better-heuristic Manhattan-distance (newboard oldboard)
  (let* ((nexttile (1+ (board-completed-chain oldboard)))
	 (currentpos (current-position nexttile oldboard)))
    (unless (equal (position-contents currentpos newboard)	; If the tile hasn't changed position,
	       nexttile)			; don't calc the manhattan distance.
      (and 
	(> (man-dist nexttile currentpos (board-side oldboard))
	   (man-dist nexttile (current-position nexttile newboard)
		     (board-side oldboard)))	; The final = test checks to prohibit undoing
	(>= (completed-chain newboard) nexttile)))	; the existing complete chain.
    ))